home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / lap.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  17KB  |  502 lines
  1. ;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; This file defines PCL's interface to the LAP mechanism.
  32. ;;;
  33. ;;; The file is divided into two parts.  The first part defines the interface
  34. ;;; used by PCL to create abstract LAP code vectors.  PCL never creates lists
  35. ;;; that represent LAP code directly, it always calls this mechanism to do so.
  36. ;;; This provides a layer of error checking on the LAP code before it gets to
  37. ;;; the implementation-specific assembler.  Note that this error checking is
  38. ;;; syntactic only, but even so is useful to have.  Because of it, no specific
  39. ;;; LAP assembler should worry itself with checking the syntax of the LAP code.
  40. ;;;
  41. ;;; The second part of the file defines the LAP assemblers for each PCL port.
  42. ;;; These are included together in the same file to make it easier to change
  43. ;;; them all should some random change be made in the LAP mechanism.
  44. ;;;
  45.  
  46. (defvar *make-lap-closure-generator*)
  47. (defvar *precompile-lap-closure-generator*)
  48. (defvar *lap-in-lisp*)
  49.  
  50. (defun make-lap-closure-generator 
  51.     (closure-variables arguments iregs vregs fvregs tregs lap-code)
  52.   (funcall-function *make-lap-closure-generator*
  53.                 closure-variables arguments iregs 
  54.                 vregs fvregs tregs lap-code))
  55.  
  56. (defmacro precompile-lap-closure-generator 
  57.     (cvars args i-regs v-regs fv-regs t-regs lap)
  58.   (funcall-function *precompile-lap-closure-generator*
  59.                     cvars args i-regs 
  60.                 v-regs fv-regs t-regs lap))
  61.  
  62. (defmacro lap-in-lisp (cvars args iregs vregs fvregs tregs lap)
  63.   (declare (ignore cvars args))
  64.   `(locally (declare #.*optimize-speed*)
  65.      ,(make-lap-prog iregs vregs fvregs tregs
  66.              (flatten-lap lap (opcode :label 'exit-lap-in-lisp)))))
  67.  
  68.  
  69. ;;;
  70. ;;; The following functions and macros are used by PCL when generating LAP
  71. ;;; code:
  72. ;;;
  73. ;;;  GENERATING-LAP
  74. ;;;  WITH-LAP-REGISTERS
  75. ;;;  ALLOCATE-REGISTER
  76. ;;;  DEALLOCATE-REGISTER
  77. ;;;  LAP-FLATTEN
  78. ;;;  OPCODE
  79. ;;;  OPERAND
  80. ;;; 
  81. (proclaim '(special *generating-lap*))        ;CAR   - alist of free registers
  82.                         ;CADR  - alist of allocated registers
  83.                         ;CADDR - max reg number allocated
  84.                         ;
  85.                         ;in each alist, the entries have
  86.                         ;the form:  (type . (:REG <n>))
  87.                         ;
  88.  
  89. ;;;
  90. ;;; This goes around the generation of any lap code.  <body> should return a lap
  91. ;;; code sequence, this macro will take care of converting that to a lap closure
  92. ;;; generator.
  93. ;;; 
  94. (defmacro generating-lap (closure-variables arguments &body body)
  95.   `(let* ((*generating-lap* (list () () -1)))
  96.      (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
  97.  
  98. (defmacro generating-lap-in-lisp (closure-variables arguments &body body)
  99.   `(let* ((*generating-lap* (list () () -1)))
  100.      (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body))))
  101.  
  102. ;;;
  103. ;;; Each register specification looks like:
  104. ;;;
  105. ;;;  (<var> <type> &key :reuse <other-reg>)
  106. ;;;  
  107. (defmacro with-lap-registers (register-specifications &body body)
  108.   ;;
  109.   ;; Given that, for now, there is only one keyword argument and
  110.   ;; that, for now, we do no error checking, we can be pretty
  111.   ;; sleazy about how this works.
  112.   ;;
  113.   (flet ((make-allocations ()
  114.        (gathering1 (collecting)
  115.          (dolist (spec register-specifications)
  116.            (gather1
  117.          `(,(car spec) (or ,(cadddr spec) (allocate-register ',(cadr spec))))))))
  118.      (make-deallocations ()
  119.        (gathering1 (collecting)
  120.          (dolist (spec register-specifications)
  121.            (gather1
  122.          `(unless ,(cadddr spec) (deallocate-register ,(car spec))))))))
  123.     `(let ,(make-allocations)
  124.        (multiple-value-prog1 (progn ,@body)
  125.                  ,@(make-deallocations)))))
  126.  
  127. (defun allocate-register (type)
  128.   (destructuring-bind (free allocated) *generating-lap*
  129.     (let ((entry (assoc type free)))
  130.       (cond (entry
  131.          (setf (car *generating-lap*)  (delete entry free)
  132.            (cadr *generating-lap*) (cons entry allocated))
  133.          (cdr entry))
  134.         (t
  135.          (let ((new `(,type . (:reg ,(incf (the fixnum (caddr *generating-lap*)))))))
  136.            (setf (cadr *generating-lap*) (cons new allocated))
  137.            (cdr new)))))))
  138.  
  139. (defun deallocate-register (reg)
  140.   (let ((entry (rassoc reg (cadr *generating-lap*))))
  141.     (unless entry (error "Attempt to free an unallocated register."))
  142.     (push entry (car *generating-lap*))
  143.     (setf (cadr *generating-lap*) (delete entry (cadr *generating-lap*)))))
  144.  
  145. (defvar *precompiling-lap* nil)
  146.  
  147. (defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code)
  148.   (when (cadr *generating-lap*) (error "Registers still allocated when lap being finalized."))
  149.   (let ((iregs ())
  150.     (vregs ())
  151.     (fvregs ())
  152.     (tregs ()))
  153.     (dolist (entry (car *generating-lap*))
  154.       (ecase (car entry)
  155.     (index  (push (caddr entry) iregs))
  156.     (vector (push (caddr entry) vregs))
  157.     (fixnum-vector (push (caddr entry) fvregs))
  158.     ((t)    (push (caddr entry) tregs))))
  159.     (cond (in-lisp-p
  160.        `(lap-in-lisp ,closure-variables ,arguments ,iregs 
  161.                      ,vregs ,fvregs ,tregs ,lap-code))
  162.       (*precompiling-lap*
  163.        (values closure-variables arguments iregs 
  164.            vregs fvregs tregs lap-code))
  165.       (t
  166.        (make-lap-closure-generator
  167.          closure-variables arguments iregs 
  168.          vregs fvregs tregs lap-code)))))
  169.  
  170. (defun flatten-lap (&rest opcodes-or-sequences)
  171.   (let ((result ()))
  172.     (dolist (opcode-or-sequence opcodes-or-sequences result)
  173.       (cond ((null opcode-or-sequence))
  174.             ((not (consp (car opcode-or-sequence)))     ;its an opcode
  175.              (setf result (append result (list opcode-or-sequence))))
  176.             (t
  177.              (setf result (append result opcode-or-sequence)))))))
  178.  
  179. (defmacro flattening-lap ()
  180.   '(let ((result ()))
  181.     (values #'(lambda (value) (push value result))
  182.      #'(lambda () (apply #'flatten-lap (reverse result))))))
  183.  
  184.  
  185.  
  186. ;;;
  187. ;;; This code deals with the syntax of the individual opcodes and operands.
  188. ;;; 
  189.   
  190. ;;;
  191. ;;; The first two of these variables are documented to all ports.  They are
  192. ;;; lists of the symbols which name the lap opcodes and operands.  They can
  193. ;;; be useful to determine whether a port has implemented all the required
  194. ;;; opcodes and operands.
  195. ;;;
  196. ;;; The third of these variables is for use of the emitter only.
  197. ;;; 
  198. (defvar *lap-operands* ())
  199. (defvar *lap-opcodes*  ())
  200. (defvar *lap-emitters* (make-hash-table :test #'eq :size 30))
  201.  
  202. (defun opcode (name &rest args)
  203.   (let ((emitter (gethash name *lap-emitters*)))
  204.     (if emitter
  205.     (apply-function (symbol-function emitter) args)
  206.     (error "No opcode named ~S." name))))
  207.  
  208. (defun operand (name &rest args)
  209.   (let ((emitter (gethash name *lap-emitters*)))
  210.     (if emitter
  211.     (apply-function (symbol-function emitter) args)
  212.     (error "No operand named ~S." name))))
  213.  
  214. (defmacro defopcode (name types)
  215.   (let ((fn-name (symbol-append "LAP Opcode " name *the-pcl-package*))
  216.     (lambda-list
  217.       (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types)))
  218.     `(progn
  219.        (eval-when (l